home *** CD-ROM | disk | FTP | other *** search
/ BMUG Revelations / BMUG Revelations.toast / Programming / Programming Languages / Yerk 3.64 / Float source / fpI⁄O < prev    next >
Text File  |  1993-01-27  |  14KB  |  367 lines
  1. \ FPI/O -- floating-point I/O support for 68000 SANE engine.
  2. \  5/11/85  ssg Version 1.0
  3. \  9/26/85  cbd Modified for float heap, removed minor methods
  4. \  2/07/86  gdc Added words atof and f.r, changed eprint to eprint, printxyz
  5. \  8/16/86  cdn Eliminated finit & Stringer shorten
  6. \  5/26/91  rfl    Eliminated Stringer class altogether.
  7. \ 10/26/91    rfl    abs in front of /mod
  8. \ 12/17/92    rfl fixed a few problems that might occur due to not locking handles
  9. \ 01/26/93    rfl    protect parse: to reject a possible float if 2 decimal points are mistakenly
  10. \                 adjacent. The case of " 1.234.56" is interpreted as an integer
  11. Decimal
  12.  
  13. \ Some useful constants
  14. 256 constant neg
  15.   0 constant pos
  16. 256 constant FixedDecimal
  17.   0 constant FloatDecimal
  18.   0 value topxyz              \ top of string being converted to float
  19. sCon zeros "000000000000000000000000000000000000000000000000000000000000000000000000000"
  20.  
  21. :CLASS      FPI/O   <Super Object
  22.  
  23.             \ SANE Record Decimal ( x:= (-1)^sgn * 10^exp * SigDig )
  24.             INT sgn     \ sign; 0=pos, 256=neg
  25.             INT exp     \ as if decimal point were to the right of SigDig
  26.             22 BYTES SigDig \ to fake string[20] ; 22 to make even
  27.  
  28.             \ SANE Record DecForm
  29.             INT style   \ Float=0; Fixed=256
  30.             INT digits  \ # of sig digits,if float; # dec. places,if fixed.
  31.  
  32.             BasicStr outStr         \ to hold formatted output string
  33.             BasicStr expStr         \ to hold formatted exponent string
  34.             String   floater        \ to hold number for makefloat
  35.             var      places         \ number of places to right of dec. pt.
  36.  
  37.             2 BYTES  scratch
  38.             BasicStr char           \ scratch character
  39.  
  40. ( -- )
  41. :M  CLEAR:          addr: sgn 26 erase clear: outStr clear: expstr
  42.                     clear: floater clear: char              ;M
  43.  
  44. ( -- )              \ Initialize strings etc.
  45. :M  INIT:           new: outStr new: expStr
  46.                     new: floater new: char clear: self      ;M
  47.  
  48. ( -- )
  49. :M  EINIT:          clear: self FloatDecimal put: style 19 put: digits  ;M
  50.  
  51. ( -- )              \ Initialize for fixed conversion
  52. :M  FINIT:          clear: self FixedDecimal put: style     ;M
  53.  
  54. ( -- )              \ Puts a zero in decimal record
  55. :M  ZERO:           clear: self  $ 0130 addr: sigDig w!     ;M
  56.  
  57. ( -- float )   \ ==== attempt to convert decimal to a float;
  58. :M  DEC2FLOAT:  { \ flt  -- flt }
  59.         abs: sgn   \ Addr of decimal record
  60.         new: fltMem -> flt  flt 2+ +base    \ Absolute Destination address
  61.         $ 0009 \ FFEXT FOD2B + -- Opcode for decimal to binary; dest=extended
  62.         fp68k       flt        \ Call FP68K
  63.     ;M
  64.  
  65. ( float -- )          \ ==== convert float to decimal  ==== \
  66. :M  FLOAT2DEC:  { flt -- }
  67.         abs: style   \ Absolute Addr of Decform record
  68.         flt 2+ +base          \ Absolute Addr of source
  69.         abs: sgn   \ Absolute Addr of Decimal record
  70.         $ 000b \ FFEXT FOB2D + -- Opcode for binary to decimal; source=extended
  71.         fp68k  flt fdrop     \ Call FP68K, dispose of float
  72.     ;M
  73.  
  74. ( width -- )        \ Set up float for in decimal record in scientific format,
  75. \                          left-justified in a field of width characters.
  76. :M  PRINTXYZ:   { flag1 width \ expn flag -- EXPSTR OUTSTR flag }
  77.             false -> flag
  78.             get: sgn neg = IF ascii - ELSE bl THEN
  79.             addr: sigDig count drop             \ addr  --
  80.             c@  CASE
  81.             ascii 0 flag1 or OF emit
  82.                " 0.E+0 " type  width 7 - spaces  ENDOF
  83.             ascii I OF  emit " Infinity " type width 10 - spaces        ENDOF
  84.             ascii N OF  emit width 14 >
  85.                         IF " Not a number " type width 14 - spaces
  86.                         ELSE " NaN " type width 5 - spaces
  87.                         THEN                                            ENDOF
  88.             ( default )
  89.             flag1 IF 26 -> width THEN
  90.             true -> flag
  91.             swap +: outstr      \ prefix with sign determined in first line
  92.             ascii E +: expstr
  93.             get: exp get: digits 1- + dup abs -> expn 0<
  94.             IF ascii - ELSE ascii + THEN +: expStr  \ put in sign of exponent
  95.             BEGIN
  96.                 2 moveto: expStr expn abs 10 /mod -> expn
  97.                 $ 30 + addr: scratch c!
  98.                 addr: scratch 1 insert: expStr
  99.                 expn not
  100.             UNTIL bl +: expstr
  101.             addr: sigDig  count add: outStr         \ Copy Sigdig to outStr
  102.             2 moveto: outStr ascii . addr: scratch c!
  103.             addr: scratch 1 insert: outStr          \ Put in decimal pt.
  104.             ENDCASE
  105.             flag       ;M
  106.  
  107. :M  EPRINT:         { width -- }
  108.             false width printxyz: self
  109.             IF      ( flag from printxyz )
  110.             get: expStr dup                         \ addr len len --
  111.             width swap - 3 max 19 min               \ addr len trlen --
  112.             get: outstr drop swap type type
  113.             THEN                ;M
  114.                                 
  115.    (  -- char t OR f )          \ does basicstr next for suppressing 0's
  116. :M NEXT0:           { -- char t / f }
  117.    next: floater next: floater drop ascii . =
  118.    IF
  119.       drop drop false
  120.    ELSE
  121.       where: floater 1- moveto: floater
  122.    THEN                         ;M
  123.  
  124.                                 \ Converts an e. type float into a normal float
  125.                                 \ without an E.
  126. :M MAKEFLOAT:       { width decimal \ dot exp -- floater }
  127.    size: expstr 1- setSize: expstr
  128.    2 moveto: expstr 0 next: expstr
  129.    BEGIN
  130.    WHILE
  131.       ascii 0 - + 10 * next: expstr         \ find size of exponent
  132.    REPEAT
  133.    10 / -> exp
  134.    zeros put: floater                       \ create initial floater
  135.    lock: outStr get: outstr 1- swap 1+ swap add: floater unlock: outStr
  136.    zeros add: floater 0 moveto: floater
  137.    ascii . charof: floater drop -> dot           \ find location of dot
  138.    " ." delete: floater                          \ drop dot
  139.    1 moveto: expstr next: expstr drop ascii - =  \ find sign of exponent
  140.    IF
  141.       dot exp -                                  \ - exponent
  142.    ELSE
  143.       dot exp +                                  \ + exponent
  144.    THEN
  145.    dup -> dot moveto: floater " ." insert: floater      \ put new dot place
  146.    dot decimal + get: floater drop + dup put: places
  147.    BEGIN                          \ round off decimals
  148.       c@ ascii 4 >            \ if last digit is less then 5 then truncate
  149.       IF
  150.          get: places c@ ascii 9 >            \ if carry then set digit to 0
  151.          IF
  152.             ascii 0 clear: char +: char
  153.             get: places get: floater drop - moveto: floater
  154.             1 substr: floater get: char replace: floater
  155.          THEN 
  156.          get: places 1- dup dot get: floater drop + =    \ check for dot
  157.          IF 1- THEN dup put: places
  158.          c@ 1+ clear: char +: char                       \ add one to digit
  159.          get: places get: floater drop - moveto: floater \ insert digit
  160.          1 substr: floater get: char replace: floater
  161.          get: places c@ ascii 9 >                         \ if there is a carry
  162.          IF                                              \ do next left digit
  163.             true
  164.          ELSE
  165.             false
  166.          THEN
  167.       ELSE
  168.          false
  169.       THEN
  170.    WHILE
  171.       get: places
  172.    REPEAT 
  173.    get: floater drop dot decimal +                 \ drop excess right digits
  174.    put: floater
  175.    32 +: floater                                   \ add space at end
  176.    size: floater width - 0 0 moveto: floater       \ drop excess left digits
  177.    BEGIN
  178.       2dup <>
  179.    WHILE
  180.       next: floater drop ascii 0 =
  181.       IF
  182.          1+
  183.       ELSE
  184.          swap drop dup
  185.       THEN
  186.    REPEAT swap drop
  187.    size: floater over - over moveto: floater
  188.    substr: floater put: floater drop
  189.    0 moveto: floater 0 next0: self                 \ suppress leading 0's
  190.    BEGIN
  191.    WHILE
  192.       ascii 0 =
  193.       IF
  194.          1+ next0: self
  195.       ELSE
  196.          false
  197.       THEN
  198.    REPEAT
  199.    dup size: floater over - swap moveto: floater substr: floater
  200.    put: floater
  201.    0 moveto: floater                              \ add sign at front
  202.    get: sgn neg =
  203.    IF
  204.       " -"
  205.    ELSE
  206.       "  "
  207.    THEN
  208.    insert: floater
  209.    0 moveto: floater 0        \ add spaces for suppressed 0's
  210.    DO
  211.       "  " insert: floater
  212.    LOOP                          ;M
  213.  
  214.                                  \ Carry out f.r
  215. :M FLOATOUT:        { width decimal -- }
  216.       129 width printxyz: self
  217.       IF   ( flag from printxyz )
  218.          width 1- decimal 1+ makefloat: self
  219.          print: floater
  220.       THEN                       ;M
  221.  
  222. ( addr -- beg end dot ee t )    \ If float found; ie, decimal pt. found
  223. ( addr -- f )                   \ If no decimal pt. found
  224. :M  PARSE:          { addr \ beg end dot ee numdec -- beg end dot ee t | f }
  225.     \ ==== Parse for decimal pt. ==== \
  226.     false addr count over + dup -> topxyz swap
  227.     0 -> numDec
  228.     DO  ic@ ascii . =
  229.         IF i -> dot i 1+ c@ ascii . <>
  230.             IF drop true THEN
  231.             leave
  232.         THEN
  233.     LOOP                        \ bool --
  234.  
  235.     IF  1 ++> addr              \ Process sign
  236.         pos put: sgn
  237.         addr c@ dup ascii - =
  238.         IF  1 ++> addr neg put: sgn THEN
  239.         ascii + =
  240.         IF  1 ++> addr  THEN
  241.         \ ==== Skip 0's and '.';  ==== \
  242.         BEGIN   addr c@ dup ascii 0 = swap ascii . = or
  243.                 WHILE   1 ++> addr
  244.         REPEAT
  245.         addr -> beg             \ addr of putative leading sig digit
  246.  
  247.         \ ==== Test for zero ==== \
  248.         topxyz beg <=
  249.         beg c@ dup dup ascii e = swap ascii E = rot bl = or or or
  250.         IF  -2 -> ee  true      \ signal that float is zero
  251.  
  252.         ELSE  \ ==== Parse for 'E' or end of string ==== \
  253.             false -> ee ee not       \ Use ee as a flag now
  254.             BEGIN
  255.                 addr topxyz - land
  256.             WHILE
  257.                 1 ++> addr
  258.                 addr c@
  259.                 CASE            \ Test for blank or e; true -> ee if found
  260.                      bl OF -1 -> ee     ENDOF
  261.                 ascii e OF addr  -> ee  ENDOF
  262.                 ascii E OF addr  -> ee  ENDOF
  263.                 ENDCASE
  264.                 ee not          \ Loop flag
  265.             REPEAT
  266.  
  267.             \ ==== Parse from end of string for last sig digit ==== \
  268.             BEGIN   -1 ++> addr
  269.                 addr c@ dup ascii 0 = swap ascii . = or
  270.                 WHILE
  271.             REPEAT
  272.             addr -> end
  273.             \ ===== Test for valid chars ===== \
  274.             true                    \ Innocent till proven guilty
  275.             end 1+ beg
  276.             DO  ic@ 10 digit        \ Are chars honest decimal digits?
  277.                 IF   drop
  278.                 ELSE i dot <>       \ Was it other than a decimal point?
  279.                     IF drop false leave THEN
  280.                 THEN
  281.             LOOP
  282.        THEN
  283.        IF beg end dot ee true  ELSE false THEN
  284.     ELSE    false
  285.     THEN           ;M
  286.  
  287. ( addr -- flt t OR f ) \ Converts string to float
  288.                  \ Returns true if float converted successfully
  289. :M  ATOF:          { addr \ beg end dot ee esign -- flt t OR f }
  290.     clear: self
  291.     addr count swap drop 21 <     \ Disqualify if longer than 20 chars
  292.     IF  addr parse: self
  293.     IF  -> ee -> dot -> end -> beg
  294.         \ ==== Process exponent ==== \
  295.         1 -> esign          \ Innocent until proven guilty
  296.         ee -2 =             \ Zero?
  297.         IF   zero: self     \ put a zero in decimal record
  298.         ELSE ee -1 <>       \ If scientific notation used
  299.             IF  1 ++> ee    \ Advance past 'E'
  300.                 ee c@ dup
  301.                 ascii - =
  302.                 IF  1 ++> ee -1 -> esign THEN
  303.                 ascii + =
  304.                 IF  1 ++> ee THEN
  305.                 ee -> addr      \ ee to contain exponent now
  306.                 0 -> ee
  307.                 BEGIN
  308.                     addr topxyz -
  309.                     IF
  310.                        addr c@ 10 digit
  311.                     ELSE
  312.                        false
  313.                     THEN
  314.                 WHILE
  315.                     ee 10 * + -> ee  1 ++> addr
  316.                 REPEAT
  317.             ELSE    0 -> ee
  318.             THEN
  319.             ee esign * dot end - dup 0> IF 2- ELSE 1- THEN + -> ee
  320.             ee put: exp
  321.  
  322.             \ ==== copy digit string to SigDig ==== \
  323.             1 -> ee             \ Use ee as counter
  324.             end 1+ beg
  325.             DO  i dot <>        \ Copy unless decimal point
  326.                 IF  ic@  addr: sigDig ee + c!  1 ++> ee THEN
  327.             LOOP
  328.             ee addr: sigDig c!  \ Store count byte
  329.         THEN
  330.         dec2float: self         \ attempt conversion to float
  331.         fdup
  332.         float2dec: self         \ reconvert to confirm
  333.         addr: sigDig 1+ c@ dup dup
  334.         ascii I = swap ascii N = rot ascii ? = or or
  335.         IF  fdrop false    \ conversion unsuccessful 
  336.         ELSE true           \ Success!
  337.         THEN
  338.     ELSE false
  339.     THEN
  340.     ELSE false
  341.     THEN                    ;M
  342.  
  343. ;Class
  344.  
  345. fpi/o floati/o        \ The default fpi/o object
  346. init: floati/o
  347.  
  348. ( width -- )
  349. ( flt -- )  \ Print a float in scientific format in a field of width chars.
  350. : e.r   { flt width -- }
  351.         einit: floati/o  flt float2dec: floati/o
  352.         width eprint: floati/o  ;
  353.  
  354. ( flt -- )  \ Print a float in scientific format.
  355. : e.    26 e.r ;
  356.  
  357. ( addr len -- fval T ) \  Successful      \ Converts a relative str255 string
  358. ( addr len -- F )      \  Unsuccessful    \ into a floating point number.
  359. : atof    { addr len -- fval T / F }
  360.       addr len str255 -base atof: floati/o             ;
  361.  
  362. ( flt width decimal -- )  \ Print a float without exponents, in a field of
  363.                           \ width wide and of decimal places
  364. : f.r   { flt width decimal -- }
  365.         einit: floati/o  flt float2dec: floati/o
  366.         width decimal floatout: floati/o               ;
  367.